home *** CD-ROM | disk | FTP | other *** search
/ Your Choice 3 / Your Choice Software Collection 3.iso / prgmming / ssr / ssr.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1994-08-09  |  10.7 KB  |  396 lines
  1. program Simple_System_Reporter;  { see SSR.DOC for revision history and notes }
  2. uses crt, dos;
  3. const
  4.   line_vt = '│';
  5. var
  6.   dsks, pars, sers, gmss : string;
  7.  
  8.   sdspace, sd_free, sd_used : string;
  9.   dspace, d_free, d_used : real;
  10.   p_space, p_free, p_used : real;
  11.  
  12. function comma (i :real) : string; {Insert commas to break up number string.}
  13. var s : string[14];
  14.     l : shortint;
  15. begin
  16.   str (i :0 :0, s);
  17.   l:= (length (s) - 2);
  18.   while l > 1 do begin
  19.     insert (',', s, l);
  20.     dec (l, 3);
  21.   end;
  22.   comma:= s;
  23. end;
  24.  
  25. function leadingzero (w :word) : string;
  26. var
  27.   s : string;
  28. begin
  29.   str (w :0, s);
  30.   if length (s) = 1 then
  31.     s:= '0' + s;
  32.   leadingzero:= s;
  33. end;
  34.  
  35. {-----}
  36.  
  37. function DisketteDrives : Integer;
  38. { SWAG snippet, author : GAYLE DAVIS }
  39. var
  40.   Regs : Registers;
  41. begin
  42.   FILLChar (Regs, SIZEOF (Regs), #0);
  43.   INTR ($11, Regs);
  44.   if Regs.AX and $0001 = 0 then
  45.     DisketteDrives:= 0
  46.   else
  47.     DisketteDrives:= ((Regs.AX shl 8) shr 14) + 1;
  48. end;
  49.  
  50. function mouse_installed : char;
  51. { adapted from Andrew Verba's TMOUSE.pas unit }
  52. { Returns true if the mouse driver and hardware are installed.
  53.   Also resets mouse to default settings. }
  54.  
  55.   var regs : registers;
  56.   begin
  57.     regs.ax:= 0;                       { invoke mouse function 0 }
  58.     intr ($33, regs);
  59.  
  60.     if regs.ax = 0 then
  61.       mouse_installed:= 'n'
  62.     else
  63.       mouse_installed:= 'Y';
  64.   end; { function mouse_installed }
  65.  
  66. procedure check_ems (var installed :boolean; var ver, ver2 :byte);
  67. { SWAG snippet }
  68.   var
  69.     regs  :  registers;
  70.   begin
  71.     regs.ah:= $46;
  72.     intr ($67, regs);
  73.     installed:= (regs.ah = $00);
  74.     if installed then begin
  75.       ver:= (Regs.AL shr 4);
  76.       ver2:= (Regs.AL and $0F);
  77.     end;
  78.   end;
  79.  
  80. procedure CallEmm (EmmFunction :Byte; var R :Registers);
  81. { SWAG snippet }
  82.   begin
  83.     R.AH:= EmmFunction;
  84.     Intr ($67, R);
  85.     if R.AH <> 0 then
  86.       {   showhelp (9); } halt;
  87.   end;
  88.  
  89. procedure get_ems (var totalems, free_ems, used_ems :word);
  90. { SWAG snippet }
  91.   var
  92.    EmmRegs : Registers;   {Registers for interrupt calls  }
  93.   begin
  94.     CallEmm ($42, EmmRegs);
  95.     totalems:= (EmmRegs.DX);
  96.     free_ems:= (EmmRegs.BX);
  97.     used_ems:= totalems - free_ems;
  98.   end;
  99.  
  100. { function exttotal : integer; }
  101. { This code courtesy of Mark Shadley. }  { NOT currently used }
  102. {  begin
  103.       asm
  104.          Mov    AL, 18h          ; MSB of total ext in 1k blocks
  105.          Mov    DX, 70h          ; port
  106.          Out    DX, AL           ; write address to port 70
  107.          Mov    DX, 71h          ; get data from port 71
  108.          in     AL, DX           ; do it
  109.          Xchg   AH, AL           ; into MSB of AX
  110.  
  111.          Mov    AL, 17h          ; LSB of total ext in 1k blocks
  112.          Mov    DX, 70h          ;
  113.          Out    DX, AL           ; write address to port 71
  114.          Mov    DX, 71h          ; get data from port 71
  115.          in     AL, DX           ; do it (into LSB of AX)
  116.          Mov    @result, AX      ; save it
  117.       end;
  118.    end;}
  119.  
  120. procedure ioinf (var dskstr, parstr, serstr, gmsstr :string;
  121.                   var cmem, fmem, umem :word);
  122. { some code adapted from SWAG snippets and INFOPLUS }
  123.   var
  124.     equip           : word;
  125.     xbyte1          : byte;
  126.     regs            : registers;
  127.     xlong,
  128.     dosmem,
  129.     dmem            : longint;
  130.     game_installed  : char;
  131.  
  132.   begin
  133.     str (disketteDrives, dskstr);
  134.     dskstr:= line_vt + ' Diskettes ' + dskstr + ' ' + line_vt;
  135.  
  136.     with regs do begin
  137.       Intr ($11, regs);
  138.       equip:= AX;
  139.       Intr ($12, regs);
  140.       DOSmem:= longint (AX) shl 10;
  141.     end;
  142.  
  143.     xbyte1:= equip and $0E00 shr 9;
  144.     str (xbyte1, serstr);
  145.     serstr:= line_vt + ' Ser Ports ' + serstr + ' ' + line_vt;
  146.  
  147.     xbyte1:= equip and $C000 shr 14;
  148.     str (xbyte1, parstr);
  149.     parstr:= line_vt + ' Par Ports ' + parstr + ' ' + line_vt;
  150.  
  151.     if (equip and $1000) <> $1000 then
  152.       game_installed:= 'n'
  153.     else
  154.       game_installed:= 'Y';
  155.  
  156.     gmsstr:= line_vt + ' G=' + game_installed + ' Mouse=' + mouse_installed + ' ' + line_vt;
  157.  
  158.     dmem:= DOSmem div 1024;
  159.     xlong:= (DOSmem - (longint (PrefixSeg) shl 4)) div 1024;
  160.     cmem:= dmem;
  161.     fmem:= xlong;
  162.     umem:= (dmem - xlong);
  163.  
  164.   end;
  165.  
  166. {-----}
  167.  
  168. procedure sysinf;
  169.   var
  170.     ver                     : word;
  171.     dosmajor, dosminor,
  172.     dos_ver                 : string [9];
  173.     year,month,day, dow,
  174.     hour,min,sec, hund      : word;
  175.     xday,
  176.     systemdate, systemtime  : string;
  177.     disks                   : byte;
  178.     ems_exists              : boolean;
  179.     emsh, emsl              : byte;
  180.     memc, memf, memu,
  181.     totalems, free_ems, used_ems : word;
  182.   begin
  183.     ver:= dosversion;
  184.     str (lo (ver) , dosmajor);
  185.     str (hi (ver) , dosminor);
  186.     if dosminor = '' then dosminor:= '0';
  187.     if length (dosminor) = 1 then dosminor:= dosminor + '0';
  188.     dos_ver:= ('DOS ' + dosmajor + '.' + dosminor);
  189.     getdate (year, month, day, dow);
  190.     systemdate:= (leadingzero (year mod 100)) + '-' +
  191.       leadingzero (month) + '-' +
  192.       leadingzero (day);
  193.     case dow of
  194.       0 : xday:= 'Sun';
  195.       1 : xday:= 'Mon';
  196.       2 : xday:= 'Tue';
  197.       3 : xday:= 'Wed';
  198.       4 : xday:= 'Thu';
  199.       5 : xday:= 'Fri';
  200.       6 : xday:= 'Sat';
  201.     end;
  202.     xday:= ' ' + xday;
  203.     gettime (hour, min, sec, hund);
  204.     systemtime:= leadingzero (hour) + ':' +
  205.       leadingzero (min) + ':' +
  206.       leadingzero (sec);
  207.  
  208.     ioinf (dsks, pars, sers, gmss, memc, memf, memu);
  209.  
  210.     check_ems (ems_exists, emsh, emsl);
  211.     if ems_exists then
  212.       get_ems (totalems, free_ems, used_ems)
  213.     else begin
  214.       EMSh:= 0;
  215.       EMSl:= 0;
  216.       totalems:= 0;
  217.       free_ems:= 0;
  218.       used_ems:= 0;
  219.     end;
  220.     totalems:= totalems * 16;
  221.     free_ems:= free_ems * 16;
  222.     used_ems:= used_ems * 16;
  223.  
  224.     writeln (OUTPUT, line_vt, 'Vers' :9, 'Total' :7, 'Used' :7, 'Free ' :8, dsks,
  225.               ' SSR Simple System Report 1.01 ', line_vt);
  226.     writeln (OUTPUT, line_vt, dos_ver :9, memc :6, 'k', memu :6, 'k', memf :6, 'k ', sers,
  227.               ' Copyright (c) 1994 Reign Ware ', line_vt);
  228.     writeln (OUTPUT, line_vt, ' EMS ', emsh :1, '.', emsl :1, ' ',
  229.           totalems :6, 'k', used_ems :6, 'k', free_ems :6, 'k ',
  230.                 pars, ' (David Daniel Anderson) Free! ', line_vt);
  231.     writeln (OUTPUT, line_vt, ' DOS+EMS ',
  232.       memc + totalems :6, 'k', memu + used_ems :6, 'k', memf + free_ems :6, 'k ',
  233.             gmss, ' Date ', systemdate, xday,
  234.             ' at ', systemtime, ' ', line_vt);
  235.  
  236.   end;
  237.  
  238. function makebar (numb :byte) : string;
  239.   var cntr : byte;
  240.       mbar : string;
  241.       full : boolean;
  242.   begin
  243.     mbar:= '';
  244.     if numb > 0 then mbar:= '▄';
  245.  
  246.     full:= (numb > 97);
  247.  
  248.     numb:= numb div 4;
  249.  
  250.     for cntr:= 2 to numb do
  251.       mbar:= mbar + '▄';
  252.     while length (mbar) < 25 do
  253.       mbar:= mbar + '─';
  254.     if full then mbar[25]:= '▄';
  255.     makebar:= mbar;
  256.   end;
  257.  
  258. procedure writedriveinfo (cdrive :byte);
  259.   var
  260.     ds, du, df : real;
  261.     pspace, pfree, pused : real;
  262.     barl : byte;
  263.     dots : string [25];
  264.   begin
  265.     ds:= disksize (cdrive);
  266.     if DS < 0 then begin
  267.       ds:= 0;
  268.       df:= 0;
  269.     end
  270.     else
  271.       df:= diskfree (cdrive);
  272.     du:= ds - df;
  273.  
  274.     dspace:= dspace + ds; d_free:= d_free + df; d_used:= d_used + du;
  275.  
  276.     pfree:= df; pused:= du; pspace:= ds;
  277.  
  278.     if pspace > 0 then begin
  279.       pfree:= (pfree / pspace) * 100;
  280.       pused:= (pused / pspace) * 100;
  281.     end;
  282.  
  283.     ds:= ds / 1024; df:= df / 1024; du:= du / 1024;
  284.  
  285.     barl:= round (pused);
  286.     dots:= makebar (barl);
  287.  
  288.     writeln (OUTPUT,
  289.       line_vt, '  ',
  290.       chr (cdrive + 64), ':',
  291.       comma (ds) :10,
  292.       comma (du) :10,
  293.       comma (df) :10,
  294.       pused :6 :1, '%',
  295.       pfree :6 :1, '%  ',
  296.       dots, '  │');
  297.   end;
  298.  
  299. {=============================================================================}
  300.  
  301. function IsDriveValid (cDrive :Char; var bLocal, bSUBST :Boolean): Boolean;
  302. { ** SWAG snippet
  303.  
  304.   Parameters: cDrive is the drive letter, 'A' to 'Z', that's about
  305.   to be checked. if not in this range, the Function will return False.
  306.  
  307.   Returns: Function returns True if the given drive is valid, else
  308.   False (!). bLocal is set if drive is local, bSUBST if drive is
  309.   substituted. if Function returns False, the Booleans are undefined.
  310. }
  311.   var
  312.     rCPU: Dos.Registers;
  313.   begin
  314.     { --- Call Dos and process returns --- }
  315.     if not (UpCase (cDrive) in ['A'..'Z']) then
  316.       { --- letter OK?--- }
  317.       IsDriveValid:= False
  318.     else begin
  319.       { --- Valid letter, set up For the Dos-call --- }
  320.       rCPU.bx:= ord (UpCase (cDrive)) - ord ('A') + 1;
  321.       rCPU.ax:= $4409;
  322.       { --- Call the Dos IOCTL (InOutConTroL)-Functions --- }
  323.       Intr ($21, rCPU);
  324.       if (rCPU.ax and FCarry) = FCarry then
  325.         IsDriveValid:= False
  326.       else begin
  327.         { --- drive is valid, check status --- }
  328.         IsDriveValid:= True;
  329.         bLocal:= ((rCPU.dx and $1000) = $0000);
  330.         if bLocal then
  331.           bSUBST:= ((rCPU.dx and $8000) = $8000)
  332.         else
  333.           bSUBST:= False;
  334.       end;
  335.     end;
  336.   end; { IsDriveValid }
  337. {=============================================================================}
  338.  
  339. const
  340. line1 = '┌───────────────────────────────┬─────────────┬───────────────────────────────┐';
  341. line2 = '├───────────────────────────────┴─────────────┴───────────────────────────────┤';
  342. line3 = '│ Drv   Total-k    Used-k    Free-k  Used%  Free%  0─────Utilization─────100  │';
  343. line4 = '│ ··· ········· ········· ········· ······ ······  ·························  │';
  344. line5 = '└─────────────────────────────────────────────────────────────────────────────┘';
  345.  
  346. var
  347.   cCurChar : Char;          { loop counter, drive }
  348.   bLocal,
  349.   bSUBST   : Boolean;       { drive local/remote?; SUBSTed or not? }
  350.   dashes : string [25];
  351.  
  352. begin
  353.   assign (OUTPUT , '');
  354.   rewrite (OUTPUT);
  355.   writeln (OUTPUT, line1);
  356.   sysinf;
  357.   writeln (OUTPUT, line2);
  358.   writeln (OUTPUT, line3);
  359.  
  360.   dspace:= 0;
  361.   d_used:= 0;
  362.   d_free:= 0;
  363.  
  364.   for cCurChar:= 'C' to 'Z' do
  365.     if IsDriveValid (cCurChar, bLocal, bSUBST) then
  366.       if blocal and (not bSUBST) then
  367.         WriteDriveInfo (ord (cCurChar) - 64);
  368.  
  369.   dspace:= dspace / 1024;
  370.   d_free:= d_free / 1024;
  371.   d_used:= d_used / 1024;
  372.  
  373.   sdspace:= comma (dspace);
  374.   sd_free:= comma (d_free);
  375.   sd_used:= comma (d_used);
  376.  
  377.   writeln (OUTPUT, line4);
  378.  
  379.   p_free:= d_free;
  380.   p_used:= d_used;
  381.  
  382.   p_space:= (p_free + p_used);
  383.   p_free:= (p_free / p_space) * 100;
  384.   p_used:= (p_used / p_space) * 100;
  385.  
  386.   dashes:= makebar (round (p_used));
  387.  
  388.   writeln (OUTPUT, line_vt, ' ALL',
  389.     sdspace :10, sd_used :10, sd_free :10,
  390.           p_used :6 :1, '%', p_free :6 :1, '%  ',
  391.                   dashes, '  │');
  392.  
  393.   writeln (OUTPUT, line5);
  394.   close (OUTPUT);
  395. end.
  396.